home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / DATETIME.SWG / 0036_Julian Date Algorithms.pas < prev    next >
Pascal/Delphi Source File  |  1994-02-03  |  3KB  |  96 lines
  1. (*     JULIAN.PAS - test Julian algorithms
  2.  
  3.      test values: 1/1/79 = 2443875
  4.                 1/1/1900 = 2415021
  5.                   1/1/70 = 2440588
  6.                  8/28/40 = 2429870
  7.  
  8.                               Robert B. Wooster [72415,1602]
  9.                               March 1985
  10.  
  11.      Note: because of the magnitude of the numbers involved
  12.      here this probably requires an 8x87 and hence is limited
  13.      to MS or PC/DOS machines.  However, it may work with the
  14.      forthcoming BCD routines.
  15. *)
  16.  
  17. program JULIAN;
  18.  
  19. var
  20.      JNUM     : real;
  21.      month,
  22.      day,
  23.      year     : integer;
  24.  
  25. {----------------------------------------------}
  26. function Jul( mo, da, yr: integer): real;
  27. { this is an implementation of the FORTRAN one-liner:
  28.      JD(I, J, K) = K - 32075 + 1461 * (I + 4800 + (J-14) / 12) / 4
  29.      + 367 * (j - 2 - ((J - 14) / 12) * 12) / 12
  30.      - 3 * (( I + 4900 + (J - 14) / 12) / 100 / 4; where I,J,K are
  31.      year, month, and day.  The original version takes advantage of
  32.      FORTRAN's automatic truncation of integers but requires support
  33.      of integers somewhat larger than Turbo's Maxint, hence all of the
  34.      Int()'s .  The variable returned is an integer day count using
  35.      1 January 1980 as 0. }
  36.  
  37. var     i, j, k, j2, ju: real;
  38. begin
  39.      i := yr;     j := mo;     k := da;
  40.      j2 := int( (j - 14)/12 );
  41.      ju := k - 32075 + int(1461 * ( i + 4800 + j2 ) / 4 );
  42.      ju := ju + int( 367 * (j - 2 - j2 * 12) / 12);
  43.      ju := ju - int(3 * int( (i + 4900 + j2) / 100) / 4);
  44.      Jul := ju;
  45. end;  { Jul }
  46.  
  47.  
  48. {----------------------------------------------}
  49. procedure JtoD(pj: real; var mo, da, yr: integer);
  50. { this reverses the calculation in Jul, returning the
  51.      result in a Date_Rec }
  52. var     ju, i, j, k, l, n: real;
  53. begin
  54.      ju := pj;
  55.      l := ju + 68569.0;
  56.      n := int( 4 * l / 146097.0);
  57.      l := l - int( (146097.0 * n + 3)/ 4 );
  58.      i := int( 4000.0 * (l+1)/1461001.0);
  59.      l := l - int(1461.0*i/4.0) + 31.0;
  60.      j := int( 80 * l/2447.0);
  61.      k := l - int( 2447.0 * j / 80.0);
  62.      l := int(j/11);
  63.      j := j+2-12*l;
  64.      i := 100*(n - 49) + i + l;
  65.      yr := trunc(i);
  66.      mo := trunc(j);
  67.      da := trunc(k);
  68. end;  { JtoD }
  69.  
  70.  
  71.  
  72. {-----------------MAIN-----------------------------}
  73. begin
  74.      writeln('This program tests the Julian date algorithms.');
  75.      writeln('Enter a calendar date in the form MM DD YYYY <return>');
  76.      writeln('Enter a date of 00 00 00 to end the program.');
  77.  
  78.      day := 1;
  79.      while day<>0 do begin
  80.  
  81.           writeln;
  82.           write('Enter MM DD YY '); readln( month, day, year);
  83.           if day<>0 then begin
  84.                JNUM  :=  Jul( month, day, year);
  85.                writeln('The Julian # of ',month,'/',day,'/',year,
  86.                     ' is ', JNUM:10:0);
  87.                JtoD( JNUM, month, day, year);
  88.                Writeln('The date corresponding to ', JNUM:10:0, ' is ',
  89.                          month,'/',day,'/',year);
  90.                end;
  91.           end;
  92.      writeln('That''s all folks.....');
  93. end.
  94.  
  95. (* end of file JULIAN.PAS *)
  96.